home *** CD-ROM | disk | FTP | other *** search
/ TeX 1995 July / TeX CD-ROM July 1995 (Disc 1)(Walnut Creek)(1995).ISO / macros / latex209 / contrib / slatex / preproc.ss < prev    next >
Text File  |  1993-11-07  |  3KB  |  87 lines
  1. ;preproc.ss
  2. ;Macro preprocessor for SLaTeX
  3. ;(c) Dorai Sitaram, Oct. 1992, Rice University
  4.  
  5. (define *macro-alist* '())
  6.  
  7. (define define-macro-transformer
  8.   (lambda (keyword transformer)
  9.     (let ((cell (assq keyword *macro-alist*)))
  10.       (if cell
  11.           (set-cdr! cell transformer)
  12.           (set! *macro-alist*
  13.             (cons (cons keyword transformer) *macro-alist*))))))
  14.  
  15. (define gensym
  16.   (let ((n -1))
  17.     (lambda ()
  18.       ;generates an allegedly new symbol;
  19.       ;this is a gross hack since there is no standardized way of
  20.       ;getting uninterned symbols
  21.       (set! n (+ n 1))
  22.       (string->symbol (string-append "%:g" (number->string n) "%")))))
  23.  
  24. (define-macro-transformer 'fluid-let
  25.   (lambda (let-pairs . body)
  26.     (let ((x-s (map car let-pairs))
  27.           (i-s (map cadr let-pairs))
  28.           (old-x-s (map (lambda (p) (gensym)) let-pairs)))
  29.       `(let ,(map (lambda (old-x x) `(,old-x ,x)) old-x-s x-s)
  30.          ,@(map (lambda (x i) `(set! ,x ,i)) x-s i-s)
  31.          (let ((%temp% (begin ,@body)))
  32.            ,@(map (lambda (x old-x) `(set! ,x ,old-x)) x-s old-x-s)
  33.            %temp%)))))
  34.  
  35. (define-macro-transformer 'defenum
  36.   (lambda z
  37.     (let loop ((z z) (n 0) (r '()))
  38.       (if (null? z) `(begin ,@r)
  39.           (loop (cdr z) (+ n 1) 
  40.         (cons `(define ,(car z) (integer->char ,n)) r))))))
  41.  
  42. (define-macro-transformer 'defrecord
  43.   (lambda (name . fields)
  44.     (let loop ((fields fields) (i 0) (r '()))
  45.       (if (null? fields)
  46.       `(begin (define ,name (lambda () (make-vector ,i)))
  47.         ,@r)
  48.     (loop (cdr fields) (+ i 1)
  49.       (cons `(define ,(car fields) ,i) r))))))
  50.  
  51. (define-macro-transformer 'of
  52.   (lambda (r i . z)
  53.   (cond ((null? z) `(vector-ref ,r ,i))
  54.     ((and (eq? i '/) (= (length z) 1)) 
  55.      `(string-ref ,r ,(car z)))
  56.     (else `(of (vector-ref ,r ,i) ,@z)))))
  57.  
  58. (define-macro-transformer 'setf
  59.   (lambda (l r)
  60.   (if (symbol? l) `(set! ,l ,r)
  61.     (let ((a (car l)))
  62.       `(,(cond ((eq? a 'list-ref) 'list-set!)
  63.            ((eq? a 'string-ref) 'string-set!)
  64.            ((eq? a 'vector-ref) 'vector-set!)
  65.            ((eq? a 'of) 'the-setter-for-of)
  66.            (else (lerror 'setf)))
  67.     ,@(cdr l) ,r)))))
  68.  
  69. (define-macro-transformer 'the-setter-for-of
  70.   (lambda (r i j . z)
  71.   (cond ((null? z) `(vector-set! ,r ,i ,j))
  72.     ((and (eq? i '/) (= (length z) 1))
  73.      `(string-set! ,r ,j ,(car z)))
  74.     (else `(the-setter-for-of (vector-ref ,r ,i) ,j ,@z)))))
  75.     
  76. (define preprocess-macros
  77.   (lambda (e)
  78.     (if (not (pair? e)) e
  79.       (let* ((a (car e))
  80.          (c (assq a *macro-alist*)))
  81.     (cond (c (preprocess-macros (apply (cdr c) (cdr e))))
  82.           ((eq? a 'quote) e)
  83.           ((eq? a 'lambda)
  84.            (cons a (cons (cadr e)
  85.              (map preprocess-macros (cddr e)))))
  86.           (else (map preprocess-macros e)))))))
  87.